home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0187.ZIP / PIANO.PAS < prev    next >
Pascal/Delphi Source File  |  1984-09-15  |  14KB  |  479 lines
  1. {    (c) 1984 by Neil J. Rubenking  }
  2. program IBMPiano;
  3. type
  4.   NoteRecord = record
  5.                   C,CS,D,DS,E,F,FS,G,GS,A,AS,B: integer;
  6.                end;
  7.   Locations  = array[39..122] of byte;
  8.   FiledNote  = record
  9.                  Octave, Note, Duration : integer;
  10.                end;
  11.   Score      = ^item;
  12.   item       = record
  13.                  Note : FiledNote;
  14.                  next : Score;
  15.                end;
  16. Const
  17.   Notes: NoteRecord =
  18.           (C:1;CS:2;D:3;DS:4;E:5;F:6;FS:7;G:8;GS:9;A:10;AS:11;B:12);
  19. var
  20.   ToggleByte       : byte absolute $0040:$0017;
  21.   done, recording,
  22.   VeryFirst        : boolean;
  23.   octave, duration,
  24.   NoteNum          : integer;
  25.   XLoci, YLoci     : Locations;
  26.   ScreenSeg        : integer;
  27.   LastKey          : char;
  28.   style            : byte;
  29.   MusicFile        : file of FiledNote;
  30.   List, Pointer,
  31.   EndPointer       : Score;
  32.   LastTime         : real;
  33. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  34. procedure DisposeAll(var List : Score);
  35.   begin
  36.     if List <> nil then
  37.       begin
  38.         DisposeAll(List^.next);
  39.         dispose(List);
  40.       end;
  41.   List := nil;
  42.   LastTime := 0;
  43. end;
  44. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  45. procedure Attribute(row,startx,endx,att:byte);
  46. var
  47.   LocationCode : integer;
  48.   N            : byte;
  49. begin
  50.   for N := startx to endx do
  51.     begin
  52.       LocationCode := (N-1)*2 + (row-1)*160;
  53.       Mem[ScreenSeg:locationCode+1] := att;
  54.     end;
  55. end;
  56. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  57. function time: real;
  58. type
  59.   regpack = record
  60.               ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
  61.             end;
  62.  
  63. var
  64.   recpack:          regpack;             {assign record}
  65.   ah,al,ch,cl,dh:   byte;
  66.   hour,min,sec,hund :     byte;
  67.  
  68. begin
  69.   ah := $2c;                             {initialize correct registers}
  70.   with recpack do
  71.   begin
  72.     ax := ah shl 8 + al;
  73.   end;
  74.   intr($21,recpack);                     {call interrupt}
  75.   with recpack do
  76.   begin
  77.     hour := cx shr 8;
  78.     min  := cx mod 256;
  79.     sec  := dx shr 8;
  80.     hund := dx mod 256;
  81.   end;
  82.   time := hund/100 + sec + 60*min;
  83. end;
  84. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  85. procedure recorder(AnOctave,ANote : integer);
  86. var
  87.   ThisDur, ThisTime : real;
  88.   NoteToAdd         : FiledNote;
  89.   {----------------------------------------------------}
  90.    procedure AddNote(ItemToAdd:FiledNote);
  91.      begin
  92.        if VeryFirst then
  93.          begin
  94.            new(List);
  95.            List^.Note := ItemToAdd;
  96.            List^.next := nil;
  97.            EndPointer := List;
  98.            VeryFirst      := false;
  99.          end
  100.        else
  101.          begin
  102.            new(EndPointer^.next);
  103.            EndPointer       := EndPointer^.next;
  104.            EndPointer^.Note := ItemToAdd;
  105.            EndPointer^.next := nil;
  106.          end;
  107.      end;
  108.   {----------------------------------------------------}
  109.   begin
  110.     ThisTime := time;
  111.     ThisDur := ThisTime - LastTime;
  112.     ThisDur := ThisDur * 500;
  113.     if NoteNum > 1 then
  114.       begin
  115.         with NoteToAdd do
  116.           begin
  117.             Octave   := AnOctave;
  118.             note     := ANote;
  119.             Duration := trunc(ThisDur);
  120.           end;
  121.         AddNote(NoteToAdd);
  122.       end;
  123.     NoteNum := NoteNum + 1;
  124.     Attribute(4,60,62,112);
  125.     LastTime := ThisTime;
  126. end;
  127. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  128. procedure Play(Octave,Note,Duration: integer);
  129. var
  130.   Frequency: real;
  131.   I: integer;
  132. begin
  133.   if ToggleByte and 16 = 16 then duration := 0;
  134.   Frequency:=32.625;
  135.   for I:=1 to Octave do Frequency:=Frequency*2;
  136.   for I:=1 to Note-1 do Frequency:=Frequency*1.059463094;
  137.   if Duration<>0 then
  138.   begin
  139.     Sound(Round(Frequency));
  140.     Delay(Duration);
  141.     NoSound;
  142.   end else Sound(Round(Frequency));
  143. end;
  144. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  145. procedure PlayBack;
  146. begin
  147.   Pointer := List;
  148.   while Pointer <> nil do
  149.     begin
  150.       with Pointer^.Note do
  151.             play(Octave,Note,Duration);
  152.       Pointer := Pointer^.next;
  153.     end;
  154.   NoSound;
  155. end;
  156. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  157. procedure  convert(Letter : char;var note, AnOctave : integer);
  158. begin
  159.   note       := 0;
  160.   AnOctave   := octave;
  161.   with notes do
  162.   begin
  163.   case Letter of
  164.     'q': note := Notes.C;
  165.     'w': note := Notes.D;
  166.     'e': note := Notes.E;
  167.     'r': note := Notes.F;
  168.     't': note := Notes.G;
  169.     'y': note := Notes.A;
  170.     'u': note := Notes.B;
  171.     'i': begin
  172.            note := Notes.C;
  173.            AnOctave := AnOctave + 1;
  174.          end;
  175.     'o': begin
  176.            note := Notes.D;
  177.            AnOctave := AnOctave + 1;
  178.          end;
  179.     'p': begin
  180.            note := Notes.E;
  181.            AnOctave := AnOctave + 1;
  182.          end;
  183.     '[': begin
  184.            note := Notes.F;
  185.            AnOctave := AnOctave + 1;
  186.          end;
  187.     ']': begin
  188.            note := Notes.G;
  189.            AnOctave := AnOctave + 1;
  190.          end;
  191.     '2': note := Notes.CS;
  192.     '3': note := Notes.DS;
  193.     '5': note := Notes.FS;
  194.     '6': note := Notes.GS;
  195.     '7': note := Notes.AS;
  196.     '9': begin
  197.            note := Notes.CS;
  198.            AnOctave := AnOctave + 1;
  199.          end;
  200.     '0': begin
  201.            note := Notes.DS;
  202.            AnOctave := AnOctave + 1;
  203.          end;
  204.     '=': begin
  205.            note := Notes.FS;
  206.            AnOctave := AnOctave + 1;
  207.          end;
  208.     '\': begin
  209.            note := Notes.F;
  210.            AnOctave := AnOctave - 2
  211.          end;
  212.     'z': begin
  213.            note := Notes.G;
  214.            AnOctave := AnOctave - 2
  215.          end;
  216.     'x': begin
  217.            note := Notes.A;
  218.            AnOctave := AnOctave - 2
  219.          end;
  220.     'c': begin
  221.            note := Notes.B;
  222.            AnOctave := AnOctave - 2
  223.          end;
  224.     'v': begin
  225.            note := Notes.C;
  226.            AnOctave := AnOctave - 1;
  227.          end;
  228.     'b': begin
  229.            note := Notes.D;
  230.            AnOctave := AnOctave - 1;
  231.          end;
  232.     'n': begin
  233.            note := Notes.E;
  234.            AnOctave := AnOctave - 1;
  235.          end;
  236.     'm': begin
  237.            note := Notes.F;
  238.            AnOctave := AnOctave - 1;
  239.          end;
  240.     ',': begin
  241.            note := Notes.G;
  242.            AnOctave := AnOctave - 1;
  243.          end;
  244.     '.': begin
  245.            note := Notes.A;
  246.            AnOctave := AnOctave - 1;
  247.          end;
  248.     '/': begin
  249.            note := Notes.B;
  250.            AnOctave := AnOctave - 1;
  251.          end;
  252.     'a': begin
  253.            note := Notes.FS;
  254.            AnOctave := AnOctave - 2;
  255.          end;
  256.     's': begin
  257.            note := Notes.GS;
  258.            AnOctave := AnOctave - 2;
  259.          end;
  260.     'd': begin
  261.            note := Notes.AS;
  262.            AnOctave := AnOctave - 2;
  263.          end;
  264.     'g': begin
  265.            note := Notes.CS;
  266.            AnOctave := AnOctave - 1;
  267.          end;
  268.     'h': begin
  269.            note := Notes.DS;
  270.            AnOctave := AnOctave - 1;
  271.          end;
  272.     'k': begin
  273.            note := Notes.FS;
  274.            AnOctave := AnOctave - 1;
  275.          end;
  276.     'l': begin
  277.            note := Notes.GS;
  278.            AnOctave := AnOctave - 1;
  279.          end;
  280.     ';': begin
  281.            note := Notes.AS;
  282.            AnOctave := AnOctave - 1;
  283.          end;
  284.   end;  {case}
  285.   end;  {with notes}
  286. end;   {procedure}
  287. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  288. procedure LightUp(Letter:char);
  289. var
  290.   LocationCode : integer;
  291. begin
  292.   if (Xloci[Ord(Letter)] > 1)  then
  293.     begin
  294.       LocationCode := (Xloci[ord(Letter)]-1)*2 + (Yloci[Ord(Letter)]-1)*160;
  295.       Mem[ScreenSeg:locationCode+1] := 112;
  296.     end;
  297.     LocationCode := (Xloci[ord(LastKey)]-1)*2 + (Yloci[Ord(LastKey)]-1)*160;
  298.     Mem[ScreenSeg:locationCode+1] := 15;
  299. end;
  300. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  301. procedure ShowLegato(On: boolean);
  302. var
  303.   col, row, M : byte;
  304.   LocationCode : integer;
  305.   word : string[6];
  306. begin
  307.   row := 2;
  308.   if On then M := 112 else M := 15;
  309.   if On then word := 'legato' else word := '      ';
  310.   for col := 1 to 6 do
  311.     begin
  312.       LocationCode := (col + 66)*2 + (row-1)*160;
  313.       Mem[ScreenSeg:LocationCode] := ord(word[col]);
  314.       Mem[ScreenSeg:LocationCode+1] := M;
  315.     end;
  316. end;
  317. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  318. procedure GetKeys;
  319. var
  320.   C, D                 : char;
  321.   legato               : boolean;
  322.   oldToggle            : byte;
  323.   ThisNote, ThisOctave : integer;
  324. begin
  325.   OldToggle := ToggleByte;
  326.   repeat until keypressed;
  327.   read(Kbd,C);
  328.   if C = chr(27) then
  329.     begin
  330.       read(Kbd,D);
  331.         case D of
  332.             'H': Octave := Octave + 1;{up arrow}
  333.             'P': Octave := Octave - 1;{down arrow}
  334.             'M': duration := duration + 10; {left arrow}
  335.             'K': if duration > 10 then duration := duration - 10; {right}
  336.             'O': done := true; {end}
  337.             'G': begin
  338.                    if recording then
  339.                      begin
  340.                        convert(LastKey,ThisNote,ThisOctave);
  341.                        recorder(ThisOctave,ThisNote);
  342.                        LastTime := 0;
  343.                        NoteNum  := 0;
  344.                      end;
  345.                    recording := recording xor true;
  346.                  end;
  347.             'R': begin
  348.                    Attribute(10,57,60,112);
  349.                    PlayBack;
  350.                    Attribute(10,57,60,15);
  351.                  end;
  352.             'S': begin
  353.                    disposeAll(List);
  354.                    VeryFirst := true;
  355.                  end;
  356.          end;
  357.     end
  358.   else
  359.     begin
  360.       LightUp(C);
  361.       convert(C,ThisNote,ThisOctave);
  362.       if ThisNote <> 0 then
  363.       play(ThisOctave,ThisNote,duration);
  364.       if recording then convert(LastKey,ThisNote,ThisOctave);
  365.       LastKey := C;
  366.     end;
  367.   if ToggleByte and 16 = 16 then legato := true else legato := false;
  368.   if recording then
  369.     begin
  370.       recorder(ThisOctave,ThisNote);
  371.     end
  372.   else
  373.     begin
  374.       Attribute(4,60,62,15);
  375.     end;
  376.   ShowLegato(legato);
  377.   gotoXY(1,26);
  378. end;
  379. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  380. procedure SetLocations;
  381. var
  382.   N : byte;
  383. begin
  384.   for N := 39 to 122 do
  385.     begin
  386.       Xloci[N] := 1;
  387.       Yloci[N] := 1;
  388.     end;
  389.   Yloci[50]  := 2;  Xloci[50]  := 11;
  390.   Yloci[51]  := 2;  Xloci[51]  := 15;
  391.   Yloci[53]  := 2;  Xloci[53]  := 23;
  392.   Yloci[54]  := 2;  Xloci[54]  := 27;
  393.   Yloci[55]  := 2;  Xloci[55]  := 31;
  394.   Yloci[57]  := 2;  Xloci[57]  := 39;
  395.   Yloci[48]  := 2;  Xloci[48]  := 43;
  396.   Yloci[61]  := 2;  Xloci[61]  := 51;
  397.   Yloci[113] := 4;  Xloci[113] := 8;
  398.   Yloci[119] := 4;  Xloci[119] := 12;
  399.   Yloci[101] := 4;  Xloci[101] := 16;
  400.   Yloci[114] := 4;  Xloci[114] := 20;
  401.   Yloci[116] := 4;  Xloci[116] := 24;
  402.   Yloci[121] := 4;  Xloci[121] := 28;
  403.   Yloci[117] := 4;  Xloci[117] := 32;
  404.   Yloci[105] := 4;  Xloci[105] := 36;
  405.   Yloci[111] := 4;  Xloci[111] := 40;
  406.   Yloci[112] := 4;  Xloci[112] := 44;
  407.   Yloci[91]  := 4;  Xloci[91]  := 48;
  408.   Yloci[93]  := 4;  Xloci[93]  := 52;
  409.   Yloci[97]  := 6;  Xloci[97]  := 9;
  410.   Yloci[115] := 6;  Xloci[115] := 13;
  411.   Yloci[100] := 6;  Xloci[100] := 17;
  412.   Yloci[103] := 6;  Xloci[103] := 25;
  413.   Yloci[104] := 6;  Xloci[104] := 29;
  414.   Yloci[107] := 6;  Xloci[107] := 37;
  415.   Yloci[108] := 6;  Xloci[108] := 41;
  416.   Yloci[59]  := 6;  Xloci[59]  := 45;
  417.   Yloci[92]  := 8;  Xloci[92]  := 8;
  418.   Yloci[122] := 8;  Xloci[122] := 12;
  419.   Yloci[120] := 8;  Xloci[120] := 16;
  420.   Yloci[99]  := 8;  Xloci[99]  := 20;
  421.   Yloci[118] := 8;  Xloci[118] := 24;
  422.   Yloci[98]  := 8;  Xloci[98]  := 28;
  423.   Yloci[110] := 8;  Xloci[110] := 32;
  424.   Yloci[109] := 8;  Xloci[109] := 36;
  425.   Yloci[44]  := 8;  Xloci[44]  := 40;
  426.   Yloci[46]  := 8;  Xloci[46]  := 44;
  427.   Yloci[47]  := 8;  Xloci[47]  := 48;
  428. end;
  429. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  430. procedure DrawKeyboard;
  431. begin
  432. WriteLn('╔═══╤═══╤═══╤═══╤═══╤═══╤═══╤═══╤═══╤═══╤═══╤═══╤═══╤═════╤═══════╤═══════╗');
  433. WriteLn('║   │   │ C#│ D#│   │ F#│ G#│ A#│   │ C#│ D#│   │ F#│     │       │       ║');
  434. WriteLn('╟───┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴─┬───┼───┬───┼───┬───╢');
  435. WriteLn('║    │ C │ D │ E │ F │ G │ A │ B │ C │ D │ E │ F │ G  │   │Rec│ ',chr(24),' │   │   ║');
  436. WriteLn('╟────┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬──┴┬───┤   ├───┼───┼───┼───╢');
  437. WriteLn('║     │ F#│ G#│ A#│   │ C#│ D#│   │ F#│ G#│ A#│   │   │   │ ',chr(27),' │   │ ',chr(26),' │   ║');
  438. WriteLn('╟────┬┴──┬┴──┬┴──┬┴──┬┴──┬┴──┬┴──┬┴──┬┴──┬┴──┬┴──┬┴───┼───┼───┼───┼───┤   ║');
  439. WriteLn('║    │ F │ G │ A │ B │ C │ D │ E │ F │ G │ A │ B │    │   │End│ ',chr(25),' │   │   ║');
  440. WriteLn('╟────┴──┬┴───┴───┴───┴───┴───┴───┴───┴───┴───┴──┬┴────┼───┴───┼───┴───┤   ║');
  441. WriteLn('║       │                                       │     │ Play  │ Erase │   ║');
  442. WriteLn('╚═══════╧═══════════════════════════════════════╧═════╧═══════╧═══════╧═══╝');
  443. WriteLn;
  444. WriteLn('Up and Down arrows control the octave.');
  445. WriteLn;
  446. WriteLn('Right and Left arrows control note duration--right is shorter.');
  447. WriteLn;
  448. WriteLn('The Scroll Lock turns legato on and off.  The change takes effect');
  449. WriteLn('     on the NEXT note.');
  450. WriteLn;
  451. WriteLn('Home turns recording on and off, Ins plays back, and Del erases.');
  452. WriteLn;
  453. WriteLn('Press <End> to end');
  454. end;
  455. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  456. procedure initialize;
  457. begin
  458.     IF (Mem[0000:1040] AND 48) <> 48 THEN ScreenSeg := $B800
  459.    ELSE ScreenSeg := $B000;
  460.   Octave := 3;
  461.   LastTime := 0;
  462.   duration := 50;
  463.   done := false;
  464.   recording := false;
  465.   VeryFirst := true;
  466.   NoteNum   := 0;
  467.   style := 0;
  468.   SetLocations;
  469.   DrawKeyboard;
  470.   List := nil;
  471.   LastTime := 0;
  472. end;
  473. {«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«}
  474. begin
  475.   initialize;
  476.   repeat GetKeys until done;
  477.   NoSound;
  478.   ClrScr;
  479. end.